home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / trayicon.cls < prev    next >
Text File  |  1997-06-14  |  4KB  |  142 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CTrayIcon"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Implements ISubclass
  13. Event TrayMessage(ByVal Message As Long, ByVal ID As Long)
  14.  
  15. Public Enum EErrorTrayIcon
  16.     eeBaseTrayIcon = 13260  ' CTrayIcon
  17. End Enum
  18.  
  19. Private picIcon As StdPicture
  20. Private icodat As NOTIFYICONDATA
  21. Private iMsg As Long, hWnd As Long, procOld As Long
  22. Private emr As EMsgResponse
  23.  
  24. Sub Create(ByVal hWndA As Long, picIconA As StdPicture, sTip As String)
  25.     ' Verify that we have valid handle and icon
  26.     If IsWindow(hWndA) = False Then ApiRaise ERROR_INVALID_HANDLE
  27.     If picIconA.Type <> vbPicTypeIcon Then ApiRaise ERROR_INVALID_DATA
  28.     ' Register a unique message based on object pointer
  29.     hWnd = hWndA
  30.     iMsg = RegisterWindowMessage(Hex$(ObjPtr(Me)))
  31.     If iMsg = 0 Then ApiRaise Err.LastDllError
  32.     ' Fill the structure and pass to Shell_NotifyIcon
  33.     Set picIcon = picIconA
  34.     icodat.cbSize = Len(icodat)
  35.     icodat.hWnd = hWnd
  36.     ' ID is same as message
  37.     icodat.uID = iMsg
  38.     ' Handle message, icon, and tip
  39.     icodat.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
  40.     icodat.uCallbackMessage = iMsg
  41.     icodat.hIcon = picIcon.Handle
  42.     MBytes.StrToBytes icodat.szTip, sTip
  43.     If Shell_NotifyIcon(NIM_ADD, icodat) = False Then
  44.         ApiRaise Err.LastDllError
  45.     End If
  46.     Debug.Print "Create notify icon"
  47.     ' Subclass this message
  48.     AttachMessage Me, hWnd, iMsg
  49. End Sub
  50.  
  51. Sub Destroy()
  52.     If iMsg = 0 Then Exit Sub
  53.     Debug.Print "Destroy notify icon"
  54.     ' Unsubclass the message and destroy the icon
  55.     DetachMessage Me, icodat.hWnd, icodat.uCallbackMessage
  56.     Shell_NotifyIcon NIM_DELETE, icodat
  57.     hWnd = hNull
  58. End Sub
  59.  
  60. Property Get Message() As Long
  61.     Message = icodat.uCallbackMessage
  62. End Property
  63.  
  64. Property Get ID() As Long
  65.     ID = icodat.uID
  66. End Property
  67.  
  68. Property Get OldProc() As Long
  69.     OldProc = procOld
  70. End Property
  71.  
  72. Property Get Tip() As String
  73.     Tip = MBytes.BytesToStr(icodat.szTip)
  74. End Property
  75.  
  76. Property Let Tip(sTip As String)
  77.     If hWnd = hNull Then Exit Property
  78.     MBytes.StrToBytes icodat.szTip, sTip & vbNullChar
  79.     icodat.uFlags = NIF_TIP
  80.     Shell_NotifyIcon NIM_MODIFY, icodat
  81. End Property
  82.  
  83. Property Get Icon() As Picture
  84.     Set Icon = picIcon
  85. End Property
  86.  
  87. Property Set Icon(picIconA As Picture)
  88.     If hWnd = hNull Then Exit Property
  89.     If picIconA.Type <> vbPicTypeIcon Then Exit Property
  90.     Set picIcon = picIconA
  91.     icodat.hIcon = picIcon.Handle
  92.     icodat.uFlags = NIF_ICON
  93.     Shell_NotifyIcon NIM_MODIFY, icodat
  94. End Property
  95.  
  96. Private Sub Class_Terminate()
  97.     Destroy
  98. End Sub
  99.  
  100. ' Implement ISubclass
  101.  
  102. Private Property Let ISubclass_MsgResponse(ByVal emrA As EMsgResponse)
  103.     emr = emrA
  104. End Property
  105.  
  106. Private Property Get ISubclass_MsgResponse() As EMsgResponse
  107.     ISubclass_MsgResponse = emr
  108. End Property
  109.  
  110. Private Function ISubclass_WindowProc(ByVal hWnd As Long, _
  111.                                       ByVal iMsg As Long, _
  112.                                       ByVal wParam As Long, _
  113.                                       ByVal lParam As Long) As Long
  114.     ' Subclasser should never call unless it's our message
  115.     BugAssert iMsg = icodat.uCallbackMessage
  116.     ' Pass event back to client (message is lParam, ID is wParam
  117.     RaiseEvent TrayMessage(lParam, wParam)
  118.     ' We've finished so original WindowProc not needed
  119.     emr = emrConsume
  120. End Function
  121.     
  122. #If fComponent = 0 Then
  123. Private Sub ErrRaise(e As Long)
  124.     Dim sText As String, sSource As String
  125.     If e > 1000 Then
  126.         sSource = App.ExeName & ".TrayIcon"
  127.         Select Case e
  128.         Case eeBaseTrayIcon
  129.             BugAssert True
  130.        ' Case ee...
  131.        '     Add additional errors
  132.         End Select
  133.         Err.Raise COMError(e), sSource, sText
  134.     Else
  135.         ' Raise standard Visual Basic error
  136.         sSource = App.ExeName & ".VBError"
  137.         Err.Raise e, sSource
  138.     End If
  139. End Sub
  140. #End If
  141.  
  142.